

;; iconobj2.lsp
;; contains code to implement icon objects for the structured GUI
;; this file has icon drawing code for icon-proto and for 
;; all code for graph and stats icon object and it's bitmaps and methods
;; including transf and analy icons
;;=========================================================================
;; Copyright (c) 1992-2002 by Forrest W. Young







;;=========================================================================
;;define prototype graph and stats icon object and it's bitmaps and methods
;;including transf and analy icons
;;=========================================================================

(defproto graph-stats-icon-proto '() nil icon-proto)

(defmeth  graph-stats-icon-proto :isnew 
  (w x y width height &key (title "Untitled") (state "gray") (draw t)
     (title-separation 2) (title-back-color nil))
  (send self :null-icon #2A((1)))

  (send self :graph-stats-grey-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )  
 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 

(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 
(1 0 0 1 0 1 0 1 0 1 0 1 0 1 ) 
(1 0 1 0 1 0 1 0 1 0 1 0 0 1 ) 

(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))  
  
(print (array-dimensions (send self :graph-stats-grey-icon)))

(send self :graph-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )

(1 0 1 1 0 0 0 1 0 0 1 1 0 1 ) 
(1 0 1 1 0 1 0 0 0 1 1 0 0 1 ) 
(1 0 1 1 0 0 0 0 1 1 0 0 0 1 ) 
(1 0 1 1 0 0 0 1 1 1 1 0 0 1 ) 

(1 0 1 1 0 0 1 1 0 0 0 0 0 1 ) 
(1 0 1 1 0 1 1 0 1 1 0 0 0 1 ) 
(1 0 1 1 1 1 0 0 0 0 0 0 0 1 ) 
(1 0 1 1 1 1 1 1 1 1 1 1 0 1 ) 

(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))
  

(print (array-dimensions (send self :graph-icon)))

(send self :graph-hi-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 

(1 1 0 0 1 0 0 1 1 0 0 1 1 1 ) 
(1 1 0 0 1 1 1 1 0 0 1 1 1 1 ) 
(1 1 0 0 1 1 1 0 0 1 0 1 1 1 ) 
(1 1 0 0 1 1 0 0 1 0 0 1 1 1 ) 

(1 1 0 0 1 0 0 1 1 1 1 1 1 1 ) 
(1 1 0 0 0 0 1 1 0 0 1 1 1 1 ) 
(1 1 0 0 0 1 1 1 1 1 1 1 1 1 ) 
(1 1 0 0 0 0 0 0 0 0 0 0 1 1 ) 

(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))
  
(send self :stats-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )
 
(1 0 0 1 1 1 0 0 0 1 1 0 0 1 ) 
(1 0 0 1 1 1 0 0 0 1 1 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 1 1 0 0 1 ) 
(1 0 0 0 0 1 1 0 0 0 0 0 0 1 ) 

(1 0 0 0 0 1 1 0 0 0 0 0 0 1 ) 
(1 0 0 0 1 1 1 0 0 1 1 0 0 1 ) 
(1 0 0 1 1 1 0 0 0 1 1 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))
  
(send self :stats-hi-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 ) 

(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 
(1 1 1 0 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 0 0 1 1 1 ) 
(1 1 1 1 1 0 0 0 1 1 1 1 1 1 ) 

(1 1 1 1 1 0 0 0 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 0 1 1 0 0 1 1 1 ) 
(1 1 1 0 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 ) 

(1 1 1 1 1 1 1 1 1 1 1 1 1 0 )))  '(2 3 4 5 6 7 8 9 10 11))))


  
(send self :trans-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )

(1 0 0 0 0 0 0 1 1 0 0 0 0 1 ) 
(1 0 0 1 1 1 1 1 0 0 0 0 0 1 ) 
(1 0 0 1 1 1 1 1 1 1 1 0 0 1 ) 
(1 0 0 0 0 1 1 1 1 1 0 0 0 1 ) 

(1 0 0 0 0 1 1 0 0 0 0 0 0 1 )  
(1 0 0 0 1 1 0 0 0 0 0 0 0 1 ) 
(1 0 0 0 1 1 0 0 1 1 0 0 0 1 ) 
(1 0 0 0 1 1 1 1 1 1 0 0 0 1 ) 
 
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))



  
(send self :trans-hi-icon (apply #'bind-columns  (select (column-list #2A(
(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )

(1 1 1 1 1 1 0 0 1 1 1 1 1 1 ) 
(1 1 1 0 0 0 0 0 1 1 1 1 1 1 )  
(1 1 1 0 0 0 0 0 0 0 0 1 1 1 )  
(1 1 1 1 1 0 0 0 0 0 1 1 1 1 ) 

(1 1 1 1 1 0 0 1 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 1 1 1 1 1 1 1 1 ) 
(1 1 1 1 0 0 1 1 1 0 0 1 1 1 ) 
(1 1 1 1 0 0 0 0 0 0 1 1 1 1 ) 

(1 1 1 1 1 1 1 1 1 1 1 1 1 1 )))  '(2 3 4 5 6 7 8 9 10 11))))
  
(send self :model-icon #2A(
(1 1 1 1 1 1 1 1 1 1 )  
(1 0 0 0 0 0 1 1 0 1 ) 
(1 1 1 0 0 1 1 1 1 1 ) 
(1 1 1 1 1 1 0 0 1 1 ) 
(1 0 1 1 1 0 0 0 0 1 ) 
(1 0 0 0 0 0 1 1 0 1 ) 
(1 1 1 0 0 1 1 1 1 1 ) 
(1 1 1 1 1 1 0 0 1 1 ) 
(1 0 1 1 1 0 0 0 0 1 ) 
(1 1 1 1 1 1 1 1 1 1)));10x10
  
(send self :model-hi-icon #2A( 
(1 1 1 1 1 1 1 1 1 1) 
(1 1 1 1 1 1 0 0 1 1) 
(1 0 0 1 1 0 0 0 0 1) 
(1 0 0 0 0 0 1 1 0 1) 
(1 1 0 0 0 1 1 1 1 1) 
(1 1 1 1 1 1 0 0 1 1) 
(1 0 0 1 1 0 0 0 0 1) 
(1 0 0 0 0 0 1 1 0 1) 
(1 1 0 0 0 1 1 1 1 1) 

(1 1 1 1 1 1 1 1 1 1)));10

  (call-next-method w x y width height :title title :draw draw)
  self)






(defmeth icon-proto :draw-trans-hi-icon (&optional medium-hi-icon)
        (send self :draw-trans-icon t medium-hi-icon))

(defmeth icon-proto :draw-model-hi-icon (&optional medium-hi-icon)
        (send self :draw-model-icon t medium-hi-icon))

(defmeth icon-proto :draw-graph-hi-icon (&optional medium-hi-icon)
        (send self :draw-graph-icon t medium-hi-icon))

(defmeth icon-proto :draw-stats-hi-icon (&optional medium-hi-icon)
        (send self :draw-stats-icon t medium-hi-icon))

(defmeth icon-proto :draw-stats-icon (&optional hi ever-shown? (solid t))
  (let* ((ictype (= 3 (send self :icon-type)))
         (button "stats")
         (x (- (send self :x) 14)) ;17
         (y (+ (send self :y) 10))) ;15 0
    ;(send self :draw-arrow (+ x 15) (+ y (if ictype 3 10)) nil)
    (send self :draw-icon-button button x y hi ever-shown?)))


(defmeth icon-proto :draw-graph-icon (&optional hi ever-shown? (solid t))
  (let* ((ictype (= 3 (send self :icon-type)))
         (button "graph")
         (x (+ (send self :x) 24)) ;31 ;27
         (y (+ (send self :y) 10))) ;15 0
    ;(send self :draw-arrow (- x 6) (+ y (if ictype 3 10)) t)
    (send self :draw-icon-button button x y hi ever-shown?)))

(defmeth icon-proto :draw-trans-icon (&optional hi ever-shown? (solid t))
  (unless (= 3 (send self :icon-type))
          (let* ((button "trans")
                 (x (- (send self :x) 14)) ;21 17
                 (y (+ (send self :y) 20)));15 0
           ; (send self :draw-arrow (+ x 15) (+ y 3) nil)
            (send self :draw-icon-button button x y hi ever-shown?)
            )))

(defmeth icon-proto :draw-model-icon (&optional hi ever-shown? (solid t))
  (unless (= 3 (send self :icon-type))
          (let* ((button "model")
                 (x (+ (send self :x) 24)) ;31 27
                 (y (+ (send self :y) 20))) ;15 17
           ;(send self :draw-arrow (- x 6) (+ y 3) t)
            (send self :draw-icon-button button x y hi ever-shown?))))

(defmeth icon-proto :draw-arrow (x y lr)
  (let* ((w (send self :window))
         (c (if lr 1 -1))
         (d 3)
         (x+d (if lr x (+ x d)))
         )
    (send w :draw-color 'black)
    (send w :frame-poly (list (list (if lr x (+ x 2 d)) y)
                              (list (* c (+ 2 d)) 0)
                              (list (- (* c d)) d)
                              (list 0  (* -2 d))
                              (list (* c d) d)) nil)
    ))

(defmeth icon-proto :draw-icon-button (button button-x button-y hi ever-shown?)
"draws icon button at location button-x, button-y. is "
        (let* ((w (send self :window))
               (x (send self :x))
               (y (send self :y))
               (dc (send w :draw-color))
               (bc (send w :back-color))
               (ic (send self :icon-color))
               (es (send self :graph-ever-shown?))
               (ns (send self :graph-not-showable))
               (ears? (send w :show-icon-ears?))
               (new-style? (send w :new-icon-style?))
               (trs (equal button "trans") )
               (mod (equal button "model") )
               (sts (equal button "stats") )
               (grf (equal button "graph") )
               )
          (when (= 3 (send self :icon-type)) (send self :icon-color 'model-icon-color))
          (when (member (send self :icon-type) '(1 4 5)) (send self :icon-color 'data-icon-color))
      #|  (cond
            (;(and ever-shown? (not (equal (send w :selected-icon-object) self)))
             (and ever-shown? (not hi))
             (send w :draw-color 'black)
             (send w :back-color 'medium-blue))
            ((not (equal (send w :selected-icon-object) self))
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white))
            (hi
             (send w :draw-color 'black)
             (send w :back-color (send self :icon-color)))
            (t
             (send w :draw-color (send self :icon-color))
             (send w :back-color 'white)))
      |#  (cond
            (;(and ever-shown? (not (equal (send w :selected-icon-object) self)))
             (and ever-shown? (not hi))
             (send w :draw-color (send self :icon-color))
             (send w :back-color 'white))

            ((not (equal (send w :selected-icon-object) self))
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white))

            (hi
             (send w :draw-color 'black)
             (send w :back-color (send self :icon-color)))
            (t
             (send w :draw-color 'medium-gray)
             (send w :back-color 'white)))
          (send self :draw-side-icon 
                (cond
                  (trs (cond
                         (ns
                          (send w :draw-color 'never-shown-color)
                          (send self :graph-stats-grey-icon))
                         (t
                          (if hi (send self :trans-hi-icon)(send self :trans-icon)))))
                  (mod (if hi (send self :model-hi-icon)(send self :model-icon)))
                  (sts (if hi (send self :stats-hi-icon)(send self :stats-icon)))
                  (grf (cond
                         (ns
                          (send w :draw-color 'never-shown-color)
                            (send self :graph-stats-grey-icon))
                         (t
                          (if hi (send self :graph-hi-icon)(send self :graph-icon)))))
                  (t))
                button-x button-y w hi)
          (send w :back-color bc)
          (send w :draw-color dc)
          t))



(defmeth icon-proto :draw-side-icon  (icon x y win &optional hi)
  (let* ((sizes (array-dimensions icon))
         (h (first sizes))
         (w (second sizes))
         (dc (send win :draw-color))
         (bc (send win :back-color))
         (row (matrix (list 1 w) (repeat 1 w)))
         (col (matrix (list h 1) (repeat 1 h))))
(print (list h w))
    (when hi (send win :draw-color bc) 
          (send win :back-color dc))
    ;  (t (send win :draw-color 'medium-blue))

    (send win :draw-bitmap icon x y)
    (send win :draw-color  'black)
    (send win :frame-rect x y w h)
    (send win :draw-line (+ x w) (+ y 1) (+ x w) (+ y h 1))
    (send win :draw-line (+ x 1) (+ y h) (+ x w 1) (+ y h))
    (send win :back-color bc)
    (send win :draw-color dc)))



